home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Magnum One
/
Magnum One (Mid-American Digital) (Disc Manufacturing).iso
/
d26
/
cattest.arc
/
UTILITY.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1991-07-01
|
41KB
|
1,214 lines
UNIT UTILITY;
(*
August 7, 1990; added erase after Pause, YesNo
August 14, 1990; added Clear_all_blanks,
added erasures at all exits to Read_Eqn
October 14, 1990; added requirements for "good" input
Read_Real_Masked
1)cursor control
2)insert/overtype switch
3)legal character set
4)legal function and editing keys
5)default value on input entry
6)default value on exit by ESC
by adding Read_Masked_Number, and attempt using a
'+0.yyyE+00' type mask to get input acceptable.
October 26, 1990; added changes to sound (NOISE)
November 21, 1990; added Read_Integer_Masked, cloned from above.
November 28, 1990; changed read_integer_masked to get sign position
correct.
November 30, 1990; added Frame
YesNo defaults to No if Carriage Return
December 1, 1990 Txt := '' in read_integer_masked
PF keys assigned
January 4, 1991 Removed limits from read_real, changed name to
read_float.
January 8, 1991 Added Read_fixed, changed both to ignore decimal
points.
January 11, 1991 Cleaned up 'x' and 'y' from Read_fixed and read_float
April 3, 1991 Added Fileexists
*)
INTERFACE
USES
CRT;
TYPE
Sounds = (Good,Bad,FinishedGood,FinishedBad,Acknowledge,Cont);
set_of_char = SET OF char;
CONST
OK_Message : STRING = 'O.K.';
Not_OK_Message : STRING = 'Not O.K.';
PF1 = #59;
PF2 = #60;
PF3 = #61;
PF4 = #62;
PF5 = #63;
PF6 = #64;
PF7 = #65;
PF8 = #66;
PF9 = #67;
PF10 = #68;
VAR
Err,ErrPos : integer; {Error response from Checking, and position}
Contents : STRING; { Contains a formula or some text }
Escape_struck, {Global Variable which tells if ESC pressed}
PF : Boolean; {Global Variable which tells if Function Keys pressed}
Ch,
variable : Char;
lc_var,uc_var : CHAR; { known case versions of variable }
question : STRING; {contains the question to be asked}
PROCEDURE NOISE(WhatSound:Sounds);
FUNCTION Read_Key: char;
(* page layout
X=1->80...
Y --------------------------
= |
1 |
| |
2 |
5 |
*)
PROCEDURE Our_Write(x,
y: {positions of cursor for first character}
integer;
s: {string to be written}
STRING);
FUNCTION YesNo(x,
y: {positions of cursor for first character of prompt}
integer;
s: {prompt text}
STRING): boolean;
PROCEDURE Pause(x,
y: {positions of cursor for first character of prompt}
integer;
s: {prompt text}
STRING);
PROCEDURE CheckBrackets(Str: {formula containing string to be checked}
STRING;
VAR Err: {Code for error <>0 means yes}
Integer;
VAR Err_Message: {message string}
STRING);
PROCEDURE Remove_double_blanks(VAR Str:STRING);
PROCEDURE Remove_all_blanks(VAR Str:STRING);
PROCEDURE Trim_fore_aft(VAR Str:STRING);
PROCEDURE PoseQuestion(line: {y position of line, x=1 assumed}
INTEGER;
question: {text of question, max length 255}
STRING);
FUNCTION Read_Eqn(X,Y,L:integer;s:STRING): STRING; {original, obsolete}
FUNCTION Read_Number(X,Y,L:integer;s:STRING): STRING; {original, obsolete}
FUNCTION Read_Masked_Number(X,Y:integer;s,mask:STRING): STRING; {original, obsolete}
FUNCTION Read_Equation(X,
Y, {positions of cursor for first character of prompt}
L: {length of string allowed for this equation}
integer;
s:
STRING;
char_set:
set_of_char): STRING;
PROCEDURE Read_Float_Masked
(X,
Y, {position of prompt}
L: {number of places to right of decimal point}
integer;
Prompt:
STRING;
Print_Prompt : {show old value?}
Boolean;
VAR W : {resultant value/or original one}
real);
PROCEDURE Read_Fixed_Masked
(X,
Y, {position of prompt}
L_left,
L_right {number of places to left and
right of decimal point}
:integer;
Prompt:STRING;
Print_Prompt : Boolean; {show old value?}
VAR W : real);
PROCEDURE Read_Integer_Masked
(X,
Y, {position of prompt}
L {number of digits}
:integer;
Prompt
:STRING;
Print_Prompt {show old value?}
: Boolean;
VAR W {resultant value/or original one}
: integer);
PROCEDURE Frame(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
function FileExists(fn:string):boolean;
IMPLEMENTATION
PROCEDURE NOISE(WhatSound:Sounds);
{This procedure was invented by Peter Sawatzki, IN307@DHAEU11.bitnet
address current as of Sept 26, 1990 }
VAR i,j : Byte;
BEGIN
CASE WhatSound OF
Cont :
BEGIN
Sound(500);
Delay(5);
END;
Good :
BEGIN
Sound(500);
Delay(30);
END;
Bad :
BEGIN
Sound(100);
Delay(200);
Sound(200);
Delay(200);
Sound(300);
Delay(200);
END;
FinishedGood : FOR j := 1 TO 2 DO
FOR i := 1 TO 5 DO
BEGIN
Sound(500+i*200);
Delay(30);
END;
FinishedBad : FOR j := 1 TO 2 DO
FOR i := 1 TO 5 DO
BEGIN
Sound(200-i*20);
Delay(30);
END;
Acknowledge :
BEGIN
Sound(1000);
Delay(15);
END;
END;
NoSound;
END;
FUNCTION Read_Key: char;
VAR
temp_var : char;
BEGIN
Temp_var := ReadKey;
PF := False; {this was not a PF key}
IF Temp_var = #0
THEN PF := True; {Oh Yes it was, so read again}
IF PF
THEN Temp_var := ReadKey;
Escape_struck := False;
IF Temp_var = #27
THEN Escape_struck := True;
Read_key := Temp_var;
END;
PROCEDURE Our_Write(X,Y:integer;s:STRING);
BEGIN {effect is to terminate line properly without carriage return}
GoToXY(X,Y);
Write(s);
ClrEol;
END;
FUNCTION YesNo(X,Y:integer;s:STRING): boolean;
BEGIN
YesNo := False;
REPEAT
Our_Write(X,Y,s);
Ch := Read_Key;
Ch := UpCase(Ch);
UNTIL Ch IN ['Y','N',#13];
IF Ch = 'Y'
THEN YesNo := True
ELSE YesNo := False;
GoToXY(X,Y);
ClrEol;
END;
PROCEDURE Pause(x,y:integer;s:STRING);
BEGIN
Our_Write(x,y,s);
Ch := Read_Key;
GoToXY(x,y);
ClrEol;
END;
PROCEDURE CheckBrackets(Str:STRING;
VAR Err:Integer; {Code for error <>0 means yes}
VAR Err_Message:STRING); {message string}
VAR
i,k : integer;
BEGIN
Err := 0;
Err_Message := OK_Message;
i := 0;
FOR k := 1 TO Length(Str) DO
BEGIN
IF Str[k] = '('
THEN inc(i)
ELSE IF Str[k] = ')'
THEN dec(i);
END;
IF i <> 0
THEN
BEGIN
Err := 1;
Err_Message := 'Brackets do not match.';
END;
END;
PROCEDURE Remove_double_blanks(VAR Str:STRING);
VAR
k : integer;
BEGIN
k := POS(' ',Str);
WHILE k > 0 DO
BEGIN
delete(Str,k,1);
k := POS(' ',Str);
END;
END;
PROCEDURE Remove_all_blanks(VAR Str:STRING);
VAR
k_blank : integer;
BEGIN
k_blank := POS(' ',Str);
WHILE k_blank <> 0 DO
BEGIN
Delete(Str,k_blank,1);
k_blank := POS(' ',Str);
END;
END;
PROCEDURE Trim_fore_aft(VAR Str:STRING);
BEGIN
WHILE Str[1] = ' ' DO
delete(Str,1,1);
WHILE Str[Length(Str)] = ' ' DO
delete(Str,Length(Str),1);
END;
PROCEDURE PoseQuestion(line:INTEGER;question:STRING);
VAR
k,kk,ypos : Integer;
BEGIN {purpose is to write a question on the screen without splitting
words.}
Remove_Double_blanks(question);
GoToXY(1,line);
k := 79;
ypos := line;
WHILE Length(question) > 79 DO
BEGIN
WHILE question[k]<>' ' DO
dec(k); {find last blank less than 80
characters in from r.h.s}
IF k <2
THEN
BEGIN
Pause(1,25,'Your text can not be split into 80 char units.');
halt;
END;
FOR kk := 1 TO k DO
Write(question[kk]); {write those characters}
ClrEol; {clean up the rest of the line.}
inc(ypos); {goto next line}
GoToXY(1,ypos);
IF k > 1
THEN Delete(question,1,k); {delete part written out already}
END;
Write(question);
ClrEol; {write the last section and clean up.}
END; {PoseQuestion}
FUNCTION Read_Eqn(X,Y,L:integer;s:STRING): STRING;
VAR
Ichar : char;
done : Boolean;
s1 : STRING;
CONST
CR = #13; {Carriage Return}
BS = #8; {Back Space}
BEGIN
uc_var := UpCase(variable);
IF variable = uc_var
THEN
lc_var := CHR(ORD(variable)+$20);
s1 := '';
done := False;
Our_Write(X,Y,s);
IChar := #0; {set to not carriage return }
WHILE (Ichar <> CR) AND (Length(s1)<= L)
DO {do not continue past the Carriage Return}
BEGIN
REPEAT
IChar := Read_Key; {get a character }
IF Escape_Struck
THEN
BEGIN
s1 := '';
GoToXY(X,Y);
ClrEol;
exit;
END;
UNTIL Ichar IN ['0'..'9','.',
{ legal numerics }
CR,
{ line terminator and end }
BS,
{ back space, erase last char }
variable,
{ the global char used as variable }
lc_var,
uc_var,
{upper / lower case versions of var }
'+','-','/','*', { allowed operators }
'^', { power symbol }
'(',')', { grouping symbols }
'?'];
{ UNIVERSAL help symbol }
IF Ichar = '?'
THEN
BEGIN
Read_Eqn := Ichar;
{ ignore partial input and }
GoToXY(X,Y);
ClrEol;
exit;
{ leave this function }
END
ELSE
IF Ichar = CR
THEN done := True
{ do not append, signal finished }
ELSE
IF (Ichar = BS) AND (Length(s1) > 0 )
{ deleteable? }
THEN delete(s1,length(s1),1)
ELSE s1 := s1 + Ichar;
Our_Write(X,Y,s1);
END;
Read_Eqn := s1;
GoToXY(X,Y);
ClrEol;
END;
FUNCTION Read_Number(X,Y,L:integer;s:STRING): STRING;
VAR
Ichar : char;
done : Boolean;
s1 : STRING;
CONST
CR = #13; {Carriage Return}
BS = #8; {Back Space}
BEGIN
uc_var := UpCase(variable);
IF variable = uc_var
THEN
lc_var := CHR(ORD(variable)+$20);
s1 := '';
done := False;
Our_Write(X,Y,s);
IChar := #0; {set to not carriage return }
WHILE (Ichar <> CR) AND (Length(s1)<= L)
DO {do not continue past the Carriage Return}
BEGIN
REPEAT
IChar := Read_Key; {get a character }
IF Escape_Struck
THEN
BEGIN
s1 := '';
GoToXY(X,Y);
ClrEol;
exit;
END;
UNTIL Ichar IN ['0'..'9','.',
{ legal numerics }
CR,
{ line terminator and end }
BS,
{ back space, erase last char }
variable,
{ the global char used as variable }
lc_var,
uc_var,
{upper / lower case versions of var }
'+','-','/','*', { allowed operators }
'^', { power symbol }
'(',')', { grouping symbols }
'?'];
{ UNIVERSAL help symbol }
IF Ichar = '?'
THEN
BEGIN
GoToXY(X,Y);
ClrEol;
exit;
{ leave this function }
END
ELSE
IF Ichar = CR
THEN done := True
{ do not append, signal finished }
ELSE
IF (Ichar = BS) AND (Length(s1) > 0 )
{ deleteable? }
THEN delete(s1,length(s1),1)
ELSE s1 := s1 + Ichar;
Our_Write(X,Y,s1);
END;
Read_Number := s1;
GoToXY(X,Y);
ClrEol;
END;
FUNCTION Read_Masked_Number(X,Y:integer;s,mask:STRING): STRING;
VAR
Ichar : char;
done : Boolean;
s1 : STRING;
L : Integer;
CONST
CR = #13; {Carriage Return}
BS = #8; {Back Space}
BEGIN
uc_var := UpCase(variable);
IF variable = uc_var
THEN
lc_var := CHR(ORD(variable)+$20);
s1 := '';
done := False;
Our_Write(X,Y,s);
L := Length(mask);
IChar := #0; {set to not carriage return }
WHILE (Ichar <> CR) AND (Length(s1) <= L )
DO {do not continue past the Carriage Return}
BEGIN
REPEAT
IChar := Read_Key; {get a character }
IF Escape_Struck
THEN
BEGIN
s1 := '';
GoToXY(X,Y);
ClrEol;
exit;
END;
UNTIL Ichar IN ['0'..'9','.',
{ legal numerics }
CR,
{ line terminator and end }
BS,
{ back space, erase last char }
'^']; { power symbol }
IF Ichar = CR
THEN done := True
{ do not append, signal finished }
ELSE
IF (Ichar = BS) AND (Length(s1) > 0 )
{ deleteable? }
THEN delete(s1,length(s1),1)
ELSE s1 := s1 + Ichar;
Our_Write(X,Y,mask);
Our_Write(X,Y+L+1,s1);
END;
Read_Masked_Number := s1;
GoToXY(X,Y);
ClrEol;
END;
FUNCTION Read_Equation(X,Y,L:integer;s:STRING;char_set:set_of_char): STRING;
VAR
Ichar : char;
done : Boolean;
s1 : STRING;
operating_char_set : set_of_char;
CONST
CR = #13; {Carriage Return}
BS = #8; {Back Space}
BEGIN
operating_char_set := ['0'..'9','.', { legal numerics }
CR, { line terminator and end }
BS, { back space, erase last char }
variable, { the global char used as variable }
lc_var,
uc_var, {upper / lower case versions of var }
'+','-','/','*', { allowed operators }
'^', { power symbol }
'(',')', { grouping symbols }
'?'] + char_set;
uc_var := UpCase(variable);
IF variable = uc_var
THEN
lc_var := CHR(ORD(variable)+$20);
s1 := '';
done := False;
Our_Write(X,Y,s);
IChar := #0; {set to not carriage return }
WHILE (Ichar <> CR) AND (Length(s1) <= L)
DO {do not continue past the Carriage Return}
BEGIN
REPEAT
IChar := Read_Key; {get a character }
IF Escape_Struck
THEN
BEGIN
s1 := '';
GoToXY(X,Y);
ClrEol;
exit;
END;
UNTIL Ichar IN operating_char_set;
IF Ichar = '?'
THEN
BEGIN
Read_Equation := Ichar;
{ ignore partial input and }
GoToXY(X,Y);
ClrEol;
exit;
{ leave this function }
END
ELSE
IF Ichar = CR
THEN done := True
{ do not append, signal finished }
ELSE
IF (Ichar = BS) AND (Length(s1) > 0 )
{ deleteable? }
THEN delete(s1,length(s1),1)
ELSE s1 := s1 + Ichar;
Our_Write(X,Y,s1);
END;
Read_Equation := s1;
GoToXY(X,Y);
ClrEol;
END;
{ From: "Chunqing N. Cheng" <cncst3@unix.cis.pitt.edu>
(edited enclosure message follows)
The TechnoJock Toolkit is so lousy on real numbers, it
cannot show them correctly. It just shows very small number as all
bunches of zero's.
For me, an engineer, a program should accept a real number just like
a computer without keyboard. So, I started to modify the code.
The following is the modified part, with the capability to
1. display a real number smartly. I mean that if it cannot fit
in normal way, it goes to scientific format automatically.
So, you do not need separately procedure for this.
2. Accept scientific format.
3. retain others in original way, (hopefully).
}
FUNCTION inttoStr(i:longint): STRING;
VAR
s: STRING[11];
BEGIN
str(i,s);
inttostr := s;
END;
FUNCTION Real_to_str(Number:real;Decimals:byte): STRING;
VAR Temp : STRING;
i: byte;
sign : STRING[1];
power: word;
FUNCTION Strip(left_right,character : char;VAR s:STRING): STRING;
BEGIN
IF UpCase(left_right) = 'R'
THEN
WHILE s[length(s)] = character DO
s := copy (s,1,length(s)-1)
ELSE IF UpCase(left_right) = 'L'
THEN
WHILE s[1] = character DO
s := copy(s,2,length(s));
strip := s;
END;
CONST
Floating : byte = 3;
VAR
Width : Integer;
t1 : real;
BEGIN
Real_to_Str := '';
IF abs(number)>0.
THEN t1 := ln(ABS(number))/2.303
ELSE exit;
Width := abs(TRUNC(t1));
IF number > -1.E+11
THEN {will fit in eleven decimal digits when
made into a string, what about Planck's
constant?}
Str(Number:Width+Decimals:11
{max for TURBO},
Temp);
REPEAT
IF copy(Temp,1,1) = ' '
THEN delete(Temp,1,1);
UNTIL copy(temp,1,1) <> ' ';
Real_to_Str := Temp;
IF Decimals+7 < Width
THEN
BEGIN
Temp := Strip('R','0',Temp);
IF Temp[Length(temp)] = '.'
THEN
Delete(temp,Length(temp),1);
IF ((Temp='0') AND (Number<>0)) OR (abs(number)>1.0E12)
OR ((Temp='-0') AND (Number<>0))
THEN
BEGIN
sign := '';
IF number<0
THEN sign := '-';
number := abs(number);
power := 0;
IF number<1
THEN
BEGIN
REPEAT
power := power+1;
number := number*10;
UNTIL number >= 1;
IF sizeof(number)=6
THEN Str(Number:20:12,Temp)
ELSE Str(Number:20:8,Temp);
REPEAT
IF copy(Temp,1,1) = ' '
THEN delete(Temp,1,1);
UNTIL copy(temp,1,1) <> ' ';
Temp := Sign+Strip('R','0',Temp)+'E-'+inttoStr(power);
END
ELSE
BEGIN
REPEAT
power := power+1;
number := number/10;
UNTIL number<10;
IF sizeof(number)=6
THEN Str(Number:20:12,Temp)
ELSE Str(Number:20:8,Temp);
REPEAT
IF copy(Temp,1,1) = ' '
THEN delete(Temp,1,1);
UNTIL copy(temp,1,1) <> ' ';
Temp := Sign+Strip('R','0',Temp)+'E'+inttoStr(power);
END;
END;
Real_to_Str := Temp;
END;
END;
{================================================}
PROCEDURE Read_Line(X, {x-position of cursor at outset}
Y, {y-position of cursor at outset}
L_left,
L_right {number of places to right of decimal point}
:integer;
VAR Text {resultant character representation
of the number }
:STRING);
CONST
CursorRight = #77;
CursorLeft = #75;
Home_Key = #71;
End_Key = #79;
Ins_Key = #82;
Del_Key = #83;
BackSpace = #15;
Esc_Key = #27;
Enter_Key = #13;
VAR
k_digits,Where_sign,
Cursor_X,Cursor_Y,CursorPos : byte;
Insert,InsertMode,FirstCharPress,AllDone: Boolean;
Ch : Char;
TempText : STRING;
PROCEDURE WriteString;
BEGIN
GoToXY(Cursor_X,Cursor_Y);
Write(TempText);
ClrEol;
GoToXY(Cursor_X+CursorPos-1,Cursor_Y);
END;
PROCEDURE InsertChar;
VAR
TempCh : Char;
BEGIN
TempText[CursorPos] := Ch;
IF CursorPos < Length(TempText)
THEN
BEGIN
CursorPos := succ(CursorPos);
TempCh := TempText[CursorPos];
IF (TempCh = '.') OR
(TempCh = '+' ) OR
(TempCh = '-' ) OR
(TempCh = 'E' )
THEN CursorPos := succ(CursorPos);
END;
END;
BEGIN {main Procedure Read_Line}
FirstCharPress := false;
Cursor_X := WhereX;
Cursor_Y := WhereY;{mark end of prompt}
CursorPos := 2;
Insert := False;
AllDone := False;
IF L_left = 0
THEN
BEGIN
IF L_right > 0
THEN
BEGIN
TempText := '+0.y';
FOR k_digits := 2 TO L_right DO
TempText := TempText + 'y';
TempText := TempText+'E+00';
Where_sign := Length(TempText)-2;
END
ELSE {trick for doing integer reads}
BEGIN
TempText := ' 0';
FOR k_digits := 2 TO abs(L_right) DO
TempText := TempText+'0';
L_right := abs(L_right);
Where_sign := 0;
END;
END
ELSE
BEGIN {fixed read}
TempText := ' ';
FOR k_digits := 1 TO L_left DO
TempText := TempText + 'x';
TempText := TempText + '.';
FOR k_digits := 2 TO L_right DO
TempText := TempText + 'y';
END;
WriteString;
FirstCharPress := true;
REPEAT
Ch := ReadKey;
IF Ch = #0 {this was a function key pressed}
THEN Ch := ReadKey; {cursor pad}
Ch := upcase(Ch);
IF Ch IN [Esc_Key,Enter_Key]
THEN
BEGIN
AllDone := True;
IF CH = Esc_Key
THEN
BEGIN
Escape_Struck := True;
exit;
END
ELSE
IF Ch <> Esc_Key
THEN
BEGIN
FOR CursorPos := 1 TO Length(TempText) DO
IF (TempText[CursorPos] =
'y') OR
(TempText[CursorPos] =
'x')
THEN TempText[CursorPos] := '0';{clean
up mask}
Text := TempText;
END;
END {of carriage return or escape}
ELSE
CASE Ch OF
CursorRight :
BEGIN
IF CursorPos < length(TempText)
THEN
BEGIN
CursorPos := Succ(CursorPos);
IF (TempText[CursorPos] = '.') OR
(TempText[CursorPos] = 'E')
THEN
CursorPos := Succ(CursorPos);
GoToXY(Cursor_X + CursorPos,Cursor_Y);
END
ELSE
Noise(Bad);
END;
CursorLeft :
BEGIN
IF CursorPos > 1
THEN
BEGIN
CursorPos := Pred(CursorPos);
IF (TempText[CursorPos] = '.') OR
(TempText[CursorPos] = 'E')
THEN
CursorPos := Pred(CursorPos);
GoToXY(Cursor_X + CursorPos,Cursor_Y);
END
ELSE
Noise(Bad);
END;
Home_Key :
BEGIN
CursorPos := 1;
GoToXY(Cursor_X+CursorPos,Cursor_Y);
END;
End_Key :
BEGIN
CursorPos := Length(TempText);
GoToXY(Cursor_X + CursorPos,Cursor_Y);
END;
BackSpace : {Char_Backspace, treat as cursor}
BEGIN
IF CursorPos > 1
THEN
BEGIN
CursorPos := Pred(CursorPos);
IF (TempText[CursorPos] = '.') OR
(TempText[CursorPos] = 'E')
THEN
CursorPos := Pred(CursorPos);
GoToXY(Cursor_X + CursorPos,Cursor_Y);
END
ELSE
Noise(Bad);
END;
Esc_Key : Alldone := true;
Enter_Key :
BEGIN
Alldone := true;
IF Ch <> Esc_Key
THEN
BEGIN
FOR CursorPos := 1 TO Length(TempText) DO
IF (TempText[CursorPos] =
'y') OR
(TempText[CursorPos] =
'x')
THEN TempText[CursorPos] := '0';
{clean
up mask}
END;
Text := TempText;
END;
#43 :
BEGIN {plus sign}
IF (CursorPos = 1) OR (CursorPos =Where_sign )
THEN
InsertChar;
END;
#45 :
BEGIN {minus sign}
IF (CursorPos = 1) OR (CursorPos =Where_sign )
THEN
InsertChar;
END;
#48..#57,' ' :
BEGIN {digits, 0 to 9}
IF Ch = ' '
THEN Ch := '0';
IF (CursorPos <> 1) AND
(CursorPos <= Length(TempText)) AND
(CursorPos <> Where_sign ) AND
(TempText[CursorPos] <> '.') AND
(TempText[CursorPos] <> 'E')
THEN
InsertChar;
END;
'.' : ;
ELSE Noise(Bad);
END; {case}
FirstCharPress := false;
WriteString;
UNTIL Alldone;
END; {Proc Read_Line}
PROCEDURE Read_Float_Masked
(X,
Y, {position of prompt}
L {number of places to right of decimal point}
:integer;
Prompt:STRING;
Print_Prompt : Boolean; {show old value?}
VAR W : real);
VAR
Temp : Real;
Txt : STRING;
Valid : boolean;
Code : integer;
YT : byte;
ChR : char;
BEGIN
Txt := '';
IF W <> 0.0
THEN Txt := Real_To_Str(W,L);
IF Print_Prompt AND (Txt <> '')
THEN
Prompt := Prompt + '(old = '+Txt+'):';
Temp := W;
Valid := false;
REPEAT
GoToXY(X,Y);
ClrEol;
GoToXY(X,Y);
Write(Prompt);
Read_Line(X,Y,0,L,Txt);
IF Escape_Struck {the person hit the escape key}
THEN exit
ELSE
BEGIN
{$R-}
val(Txt,Temp,code);
{$R+}
IF code <> 0
THEN
BEGIN
noise(bad);
delay(1000);
END
ELSE
BEGIN
W := Temp; {accept as OK number}
Valid := true;
END;
END;
UNTIL valid ;
END;
PROCEDURE Read_Fixed_Masked
(X,
Y, {position of prompt}
L_left,
L_right {number of places to left and
right of decimal point}
:integer;
Prompt:STRING;
Print_Prompt : Boolean; {show old value?}
VAR W : real);
VAR
Temp : Real;
Txt : STRING;
Valid : boolean;
Code : integer;
YT : byte;
ChR : char;
BEGIN
Txt := '';
IF W <> 0
THEN Txt := Real_To_Str(W,L_left+L_right);
IF Print_Prompt AND (Txt <> '')
THEN
Prompt := Prompt + '(old = '+Txt+'):';
Temp := W;
Valid := false;
REPEAT
GoToXY(X,Y);
ClrEol;
GoToXY(X,Y);
Write(Prompt);
Read_Line(X,Y,L_left,L_right,Txt);
IF Escape_Struck {the person hit the escape key}
THEN exit
ELSE
BEGIN
{$R-}
val(Txt,Temp,code);
{$R+}
IF code <> 0
THEN
BEGIN
noise(bad);
delay(1000);
END
ELSE
BEGIN
W := Temp; {accept as OK number}
Valid := true;
END;
END;
UNTIL valid ;
END;
PROCEDURE Read_Integer_Masked
(X,
Y, {position of prompt}
L {number of digits}
:integer;
Prompt:STRING;
Print_Prompt : Boolean; {show old value?}
VAR W : integer);
VAR
Temp : Integer;
Txt : STRING;
Valid : boolean;
Code : integer;
YT : integer;
ChR : char;
BEGIN
Txt := '';
IF W <> 0
THEN Txt := IntToStr(W);
IF Print_Prompt AND (Txt <> '')
THEN
Prompt := Prompt + '(old = '+Txt+'):';
Temp := W;
Valid := false;
REPEAT
GoToXY(X,Y);
ClrEol;
GoToXY(X,Y);
Write(Prompt);
YT := -L;
Escape_Struck := False;
Read_Line(X,Y,0,YT,Txt);{use this trick to force integer}
IF Escape_Struck {the person hit the escape key}
THEN exit
ELSE
BEGIN
{$R-}
val(Txt,Temp,code);
{$R+}
IF code <> 0
THEN
BEGIN
noise(bad);
delay(1000);
END
ELSE
BEGIN
W := Temp; {accept as OK number}
Valid := true;
END;
END;
UNTIL valid ;
END;
PROCEDURE Frame(UpperLeftX, UpperLeftY, LowerRightX, LowerRightY: Integer);
VAR I : Integer;
BEGIN {Frame}
GotoXY(UpperLeftX, UpperLeftY);
Write(chr(218));
FOR I := (UpperLeftX + 1) TO (LowerRightX - 1) DO
BEGIN
Write(chr(196));
END;
Write(chr(191));
FOR I := (UpperLeftY + 1) TO (LowerRightY - 1) DO
BEGIN
GotoXY(UpperLeftX , I);
Write(chr(179));
GotoXY(LowerRightX, I);
Write(chr(179));
END;
GotoXY(UpperLeftX, LowerRightY);
Write(chr(192));
FOR I := (UpperLeftX + 1) TO (LowerRightX - 1) DO
BEGIN
Write(chr(196));
END;
Write(chr(217));
END; {Frame}
function FileExists(fn:string):boolean;
var
f : file;
begin
{$I-}
assign(f,fn);
reset(f);
close(f);
{$I+}
FileExists := (IOResult = 0) and (fn<>'');
end;
END.